home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / faq-s.zip / MAINR1.PAS < prev    next >
Pascal/Delphi Source File  |  1991-02-25  |  8KB  |  351 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit mainr1;
  5.  
  6. interface
  7.  
  8. uses modem,gentypes,configrt,textret,gensubs,subs1,userret,statret;
  9.  
  10. procedure showinfoform (var uname:mstr; ureq:integer);  { UNAME='' shows all }
  11. procedure showinfoforms (uname:mstr);  { UNAME='' shows all }
  12. function validfname (name:lstr):boolean;
  13. function searchboard (name:sstr):integer;
  14. function numfeedback:integer;
  15. procedure trimmessage (var m:message);
  16.  
  17. implementation
  18.  
  19. procedure showinfoform (var uname:mstr; ureq:integer);  { UNAME='' shows all }
  20. var lnum,un,cnt:integer;
  21.     u:userrec;
  22.  
  23.   procedure scold (u2:integer);
  24.   begin
  25.     writeln('Infoform '^S+strr(u2)+^R+' does not exist for this user.');
  26.     writeln;
  27.   end;
  28.  
  29.   procedure showone (ureq:integer);
  30.   var ff:text;
  31.       fn:lstr;
  32.       me:message;
  33.       k:char;
  34.       found:boolean;
  35.  
  36.  
  37.   begin
  38.     case ureq of
  39.         1    :if u.infoform1=-1 then begin
  40.                         scold(ureq);
  41.                         exit;
  42.                         end;
  43.         2       :if u.infoform2=-1 then begin
  44.                         scold(ureq);
  45.                         exit;
  46.                         end;
  47.         3    :if u.infoform3=-1 then begin
  48.                         scold(ureq);
  49.                         exit;
  50.                         end;
  51.         4    :if u.infoform4=-1 then begin
  52.                         scold(ureq);
  53.                         exit;
  54.                         end;
  55.         5    :if u.infoform5=-1 then begin
  56.                         scold(ureq);
  57.                         exit;
  58.                         end;
  59.         else begin
  60.              writeln('Valid choices are forms #1-5');
  61.              exit;
  62.              end;
  63.         end;
  64.  
  65.     fn:=textfiledir+'Infoform.'+strr(ureq);
  66.     assign (ff,fn);
  67.     reset (ff);
  68.     if ioresult<>0 then begin
  69.       close (ff);
  70.       lnum:=ioresult;
  71.       writeln (^B'IOERROR'^R' loading Infoform ',ureq,'.');
  72.       exit
  73.       end;
  74.  
  75.     case ureq of
  76.     1    : reloadtext(u.infoform1,me);
  77.     2    : reloadtext(u.infoform2,me);
  78.     3    : reloadtext(u.infoform3,me);
  79.     4    : reloadtext(u.infoform4,me);
  80.     5    : reloadtext(u.infoform5,me);
  81.     end;
  82.  
  83.     writeln (^M,me.text[1],^M^M);
  84.     lnum:=1;
  85.     while not (break or eof(ff)) do begin
  86.       read (ff,k);
  87.       if k='*'
  88.         then if lnum>me.numlines
  89.           then writeln ('No answer')
  90.           else begin
  91.             lnum:=lnum+1;
  92.             writeln (me.text[lnum])
  93.           end
  94.         else write (k)
  95.     end;
  96.     textclose (ff)
  97.   end;
  98.  
  99. begin
  100.   if uname='' then begin
  101.     writeln (^B^M^S'          Showing All Info-Forms'^R);
  102.     writeln;
  103.     seek (ufile,1);
  104.     for cnt:=1 to numusers do begin
  105.       read (ufile,u);
  106.       writeln (^M^M,u.handle,^M);
  107.       if u.infoform1<>-1 then showone (ureq);
  108.       if xpressed then exit
  109.     end
  110.   end else begin
  111.     un:=lookupuser (uname);
  112.     if un=0 then writeln (^B'No such user.') else begin
  113.       seek (ufile,un);
  114.       read (ufile,u);
  115.       showone (ureq);
  116.     end
  117.   end
  118. end;
  119.  
  120. procedure showinfoforms (uname:mstr);  { UNAME='' shows all }
  121. var lnum,un,cnt:integer;
  122.     u:userrec;
  123.  
  124.   procedure scold (u2:integer);
  125.   begin
  126.     writeln(^R'Infoform '^S+strr(u2)+^R+' does not exist for this user.');
  127.     writeln;
  128.   end;
  129.  
  130.   procedure showone (ureq:integer);
  131.   var ff:text;
  132.       fn:lstr;
  133.       me:message;
  134.       k:char;
  135.       found:boolean;
  136.  
  137.  
  138.   begin
  139.     case ureq of
  140.         1    :if u.infoform1=-1 then begin
  141.                         scold(ureq);
  142.                         exit;
  143.                         end;
  144.         2       :if u.infoform2=-1 then begin
  145.                         scold(ureq);
  146.                         exit;
  147.                         end;
  148.         3    :if u.infoform3=-1 then begin
  149.                         scold(ureq);
  150.                         exit;
  151.                         end;
  152.         4    :if u.infoform4=-1 then begin
  153.                         scold(ureq);
  154.                         exit;
  155.                         end;
  156.         5    :if u.infoform5=-1 then begin
  157.                         scold(ureq);
  158.                         exit;
  159.                         end;
  160.         else begin
  161.              writeln('Valid choices are forms #1-5');
  162.              exit;
  163.              end;
  164.         end;
  165.  
  166.     fn:=textfiledir+'Infoform.'+strr(ureq);
  167.     assign (ff,fn);
  168.     reset (ff);
  169.     if ioresult<>0 then begin
  170.       close (ff);
  171.       lnum:=ioresult;
  172.       writeln (^B'IOERROR'^R' loading Infoform ',ureq,'.');
  173.       exit
  174.       end;
  175.  
  176.     case ureq of
  177.     1    : reloadtext(u.infoform1,me);
  178.     2    : reloadtext(u.infoform2,me);
  179.     3    : reloadtext(u.infoform3,me);
  180.     4    : reloadtext(u.infoform4,me);
  181.     5    : reloadtext(u.infoform5,me);
  182.     end;
  183.  
  184.     writeln (^M,me.text[1],^M^M);
  185.     lnum:=1;
  186.     while not (break or eof(ff)) do begin
  187.       read (ff,k);
  188.       if k='*'
  189.         then if lnum>me.numlines
  190.           then writeln ('No answer')
  191.           else begin
  192.             lnum:=lnum+1;
  193.             writeln (me.text[lnum])
  194.           end
  195.         else write (k)
  196.     end;
  197.     textclose (ff)
  198.   end;
  199.  
  200. begin
  201.   if uname='' then begin
  202.     writeln (^B^M^S'          Showing All Info-Forms'^R);
  203.     writeln;
  204.     seek (ufile,1);
  205.     for cnt:=1 to numusers do begin
  206.       read (ufile,u);
  207.       writeln (^M^M,u.handle,^M);
  208.       if u.infoform1<>-1 then showone (1);
  209.       if u.infoform2<>-1 then showone (2);
  210.       if u.infoform3<>-1 then showone (3);
  211.       if u.infoform4<>-1 then showone (4);
  212.       if u.infoform5<>-1 then showone (5);
  213.       if xpressed then exit
  214.     end
  215.   end else begin
  216.     un:=lookupuser (uname);
  217.     if un=0 then writeln (^B'No such user.') else begin
  218.       seek (ufile,un);
  219.       read (ufile,u);
  220.       showone (1);
  221.       showone (2);
  222.       showone (3);
  223.       showone (4);
  224.       showone (5)
  225.     end
  226.   end
  227. end;
  228.  
  229. function validfname (name:lstr):boolean;
  230. const invalid:set of char=[#0..#31,'"',']','[',':','\','>','<','/','?','*',
  231.   '|','+','=',';', ',' ,#127..#255];
  232. var p,cnt:integer;
  233.     k:char;
  234.     dotfound:boolean;
  235. begin
  236.   validfname:=false;
  237.   dotfound:=false;
  238.   if (length(name)>12) or (length(name)<1) then exit;
  239.   for p:=1 to length(name) do begin
  240.     k:=upcase(name[p]);
  241.     if k in invalid then exit;
  242.     if k='.' then begin
  243.       if dotfound then exit;
  244.       dotfound:=true;
  245.       if (p<length(name)-3) or (p=1) then exit
  246.     end
  247.   end;
  248.   validfname:=not devicename(name);
  249.   if upstring(name)='USERS' then validfname:=false;
  250. end;
  251.  
  252. function searchboard (name:sstr):integer;
  253. var bi:sstr;
  254.     cnt:integer;
  255. begin
  256.   seek (bifile,0);
  257.   for cnt:=0 to filesize(bifile)-1 do begin
  258.     read (bifile,bi);
  259.     if (bi=name) then begin
  260.       searchboard:=cnt;
  261.       exit
  262.     end
  263.   end;
  264.   searchboard:=-1
  265. end;
  266.  
  267. function numfeedback:integer;
  268. var ffile:file of mailrec;
  269. begin
  270.   assign (ffile,bbsdatadir+'Feedback.dat');
  271.   reset (ffile);
  272.   if ioresult<>0 then begin
  273.     numfeedback:=0;
  274.     rewrite (ffile)
  275.   end else numfeedback:=filesize (ffile);
  276.   close (ffile)
  277. end;
  278.  
  279. procedure trimmessage (var m:message);
  280. var cnt:integer;
  281. begin
  282.   for cnt:=1 to m.numlines do
  283.     while m.text[cnt][length(m.text[cnt])]=' ' do
  284.       m.text[cnt][0]:=pred(m.text[cnt][0]);
  285.   while (m.numlines>0) and (m.text[m.numlines]='') do
  286.     m.numlines:=m.numlines-1
  287. end;
  288.  
  289. procedure printfile (fn:lstr);
  290.  
  291.   procedure getextension (var fname:lstr);
  292.  
  293.     procedure tryfiles (a,b,c,d:integer);
  294.     var q:boolean;
  295.  
  296.       function tryfile (n:integer):boolean;
  297.       const exts:array [1..4] of string[3]=('','ANS','ASC','40');
  298.       begin
  299.         if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
  300.           tryfile:=true;
  301.           fname:=fname+'.'+exts[n]
  302.         end
  303.       end;
  304.  
  305.     begin
  306.       if tryfile (a) then exit;
  307.       if tryfile (b) then exit;
  308.       if tryfile (c) then exit;
  309.       q:=tryfile (d)
  310.     end;
  311.  
  312.   begin
  313.     if pos ('.',fname)<>0 then exit;
  314.     if ansigraphics in urec.config  then tryfiles (2,3,1,4) else
  315.     if asciigraphics in urec.config then tryfiles (3,1,4,2) else
  316.     if eightycols in urec.config    then tryfiles (1,4,3,2) else
  317.                                          tryfiles (4,1,3,2)
  318.   end;
  319.  
  320. var tf:text;
  321.     k:char;
  322. begin
  323.   clearbreak;
  324.   writeln;
  325.   getextension (fn);
  326.   assign (tf,fn);
  327.   reset (tf);
  328.   iocode:=ioresult;
  329.   if iocode<>0 then begin
  330.     fileerror ('Printfile',fn);
  331.     exit
  332.   end;
  333.   clearbreak;
  334.   while not (eof(tf) or break or hungupon) do
  335.     begin
  336.       read (tf,k);
  337.       if k='`' then write (urec.timetoday) else
  338.       if k='~' then write (urec.handle) else
  339.       if k='@' then write (longname) else
  340.       write (k)
  341.     end;
  342.   if break then writeln (^B);
  343.   writeln;
  344.   textclose (tf);
  345.   curattrib:=0;
  346.   ansireset
  347. end;
  348.  
  349. begin
  350. end.
  351.